home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / turbo_tk.arc / FASTTTT.PAS < prev    next >
Pascal/Delphi Source File  |  1988-02-01  |  8KB  |  270 lines
  1. {$S-,R-,V-,D-,T-}
  2. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  3. {         TechnoJocks Turbo Toolkit v4.00            Released: Feb 1, 1988    }
  4. {                                                                             }
  5. {         Module: FastTTT   --  fast screen update procedures                 }
  6. {         Credits: Brian Foley and Marshall Brain for ASM concept             }
  7. {                                                                             }
  8. {                       Copyright R. D. Ainsbury (c) 1986                     }
  9. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  10.  
  11. unit FastTTT;
  12.  
  13. interface
  14.  
  15. type
  16.   DisplayType = (Monochrome, CGA, EGA, MCGA, VGA);
  17. var
  18.   BaseOfScreen : Word;       {Base address of video memory}
  19.   WaitForRetrace : Boolean;  {Check for snow on color cards?}
  20.   Speed : longint;           {delay factor for growbox routine}
  21.  
  22. Function  Attr(F,B:byte):byte;
  23. Procedure FastWrite(Col,Row,Attr:byte; St:string);
  24. Procedure PlainWrite(Col,Row:byte; St:string);
  25. Function  CurrentDisplay: DisplayType;
  26. Function  Replicate(N:byte; Character:char):string;
  27. Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  28. Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  29. Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  30. Procedure HorizLine(X1,X2,Y,F,B,lineType:byte);
  31. Procedure VertLine(X,Y1,Y2,F,B,lineType:byte);
  32. Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  33. Procedure ClearLine(Y,F,B:integer);
  34. Procedure WriteAT(X,Y,F,B:integer; St:string);
  35. Procedure WriteBetween(X1,X2,Y,F,B:byte; St:string);
  36. Procedure WriteCenter(LineNO,F,B:integer; St:string);
  37. Procedure WriteVert(X,Y,F,B:integer; St:string);
  38. Procedure ReinitFastWrite;
  39.  
  40. implementation
  41.  
  42.   {$L FASTTTT}
  43.  
  44.   {$F+}
  45.   Procedure FastWrite(Col,Row,Attr:byte; St:string); external;
  46.   Procedure PlainWrite(Col,Row:byte; St:string); external;
  47.   Function CurrentDisplay: DisplayType; external;
  48.   Function CurrentVideoMode: Byte; external;
  49.   {$F-}
  50.  
  51.   Function Attr(F,B:byte):byte;
  52.   {converts foreground(F) and background(B) colors to combined Attribute byte}
  53.   begin
  54.       Attr := (B Shl 4) or F;
  55.   end;  {Func Attr}
  56.  
  57.   Function Replicate(N : byte; Character:char):string;
  58.   {returns a string with Character repeated N times}
  59.   var tempstr : string;
  60.   begin
  61.       If not (N in [1..80]) then N := 1;
  62.       fillchar(tempstr,N+1,Character);
  63.       Tempstr[0] := chr(N);
  64.       Replicate := Tempstr;
  65.   end;
  66.  
  67.   Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  68.   var
  69.     Y : integer;
  70.     attrib : byte;
  71.   begin
  72.       If x2 > 80 then x2 := 80;
  73.       Attrib := attr(F,B);
  74.       For Y := y1 to y2 do
  75.           Fastwrite(X1,Y,attrib,replicate(X2-X1+1,' '));
  76.   end;   {cleartext}
  77.  
  78.   Procedure ClearLine(Y,F,B:integer);
  79.   begin
  80.       Fastwrite(1,Y,attr(F,B),replicate(80,' '));
  81.   end;
  82.  
  83.   Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  84.   {Draws a box on the screen}
  85.   var
  86.     I:integer;
  87.     corner1,corner2,corner3,corner4,
  88.     horizline,
  89.     vertline : char;
  90.     attrib : byte;
  91.   begin
  92.       case boxtype of
  93.       0:begin
  94.             corner1:=' ';
  95.             corner2:=' ';
  96.             corner3:=' ';
  97.             corner4:=' ';
  98.             horizline:=' ';
  99.             vertline:=' ';
  100.         end;
  101.       1:begin
  102.             corner1:='┌';
  103.             corner2:='┐';
  104.             corner3:='└';
  105.             corner4:='┘';
  106.             horizline:='─';
  107.             vertline:='│';
  108.         end;
  109.       2:begin
  110.             corner1:='╔';
  111.             corner2:='╗';
  112.             corner3:='╚';
  113.             corner4:='╝';
  114.             horizline:='═';
  115.             vertline:='║';
  116.         end;
  117.       3:begin
  118.             corner1:='╓';
  119.             corner2:='╖';
  120.             corner3:='╙';
  121.             corner4:='╜';
  122.             horizline:='─';
  123.             vertline:='║';
  124.         end;
  125.       4:begin
  126.             corner1:='╒';
  127.             corner2:='╕';
  128.             corner3:='╘';
  129.             corner4:='╛';
  130.             horizline:='═';
  131.             vertline:='│';
  132.         end;
  133.     else
  134.        corner1:=chr(ord(Boxtype));
  135.        corner2:=chr(ord(Boxtype));
  136.        corner3:=chr(ord(Boxtype));
  137.        corner4:=chr(ord(Boxtype));
  138.        horizline:=chr(ord(Boxtype));
  139.        vertline:=chr(ord(Boxtype));
  140.     end;{case}
  141.     attrib := attr(F,B);
  142.     FastWrite(X1,Y1,attrib,corner1);
  143.     FastWrite(X1+1,Y1,attrib,replicate(X2-X1-1,horizline));
  144.     FastWrite(X2,Y1,attrib,corner2);
  145.     For I := Y1+1 to Y2-1 do
  146.     begin
  147.         FastWrite(X1,I,attrib,vertline);
  148.         FastWrite(X2,I,attrib,vertline);
  149.     end;
  150.     FastWrite(X1,Y2,attrib,corner3);
  151.     FastWrite(X1+1,Y2,attrib,replicate(X2-X1-1,horizline));
  152.     FastWrite(X2,Y2,attrib,corner4);
  153.   end; {Proc Box}
  154.  
  155.   Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  156.   {Draws a box and clears text within Box frame}
  157.   begin
  158.       Box(X1,Y1,X2,Y2,F,B,boxtype);
  159.       ClearText(succ(X1),succ(Y1),pred(X2),pred(Y2),F,B);
  160.   end;
  161.  
  162.   Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  163.   {Draws exploding filled box!}
  164.   var I,TX1,TY1,TX2,TY2,Ratio : integer;
  165.   begin
  166.       If 2*(Y2 -Y1 +1) > X2 - X1 + 1 then
  167.          Ratio :=   2
  168.       else
  169.          Ratio :=  1;
  170.       TX2 := (X2 - X1) div 2 + X1 + 2;
  171.       TX1 := TX2 - 3;                 {needs a box 3 by 3 minimum}
  172.       TY2 := (Y2 - Y1) div 2 + Y1 + 2;
  173.       TY1 := TY2 - 3;
  174.       repeat
  175.            FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  176.            If TX1 >= X1 + (1*Ratio) then TX1 := TX1 - (1*Ratio) else TX1 := X1;
  177.            If TY1 > Y1  then TY1 := TY1 - 1;
  178.            If TX2 + (1*Ratio) <= X2 then TX2 := TX2 + (1*Ratio) else TX2 := X2;
  179.            If TY2 + 1 <= Y2 then TY2 := TY2 + 1;
  180.            For I := 1 to Speed*1000 do {nothing};
  181.       Until (TX1 = X1) and (TY1 = Y1) and (TX2 = X2) and (TY2 = Y2);
  182.       FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  183.   end;
  184.  
  185.   procedure HorizLine(X1,X2,Y,F,B,lineType : byte);
  186.   var
  187.     I : integer;
  188.     Horizline : char;
  189.     attrib : byte;
  190.   begin
  191.       If (lineType in [2,4]) then
  192.          horizline := '═'
  193.       else
  194.          horizline := '─';
  195.       Attrib := attr(F,B);
  196.       If X2 > X1 then
  197.          FastWrite(X1,Y,attrib,replicate(X2-X1+1,Horizline))
  198.       else
  199.          FastWrite(X1,Y,attrib,replicate(X1-X2+1,Horizline));
  200.   end;   {horizline}
  201.  
  202.   Procedure VertLine(X,Y1,Y2,F,B,lineType : byte);
  203.   var
  204.     I : integer;
  205.     vertline : char;
  206.     attrib : byte;
  207.   begin
  208.       If (linetype in [2,4])then
  209.          vertline := '║'
  210.       else
  211.          vertline := '│';
  212.       Attrib := attr(F,B);
  213.       If Y2 > Y1 then
  214.          For I := Y1 to Y2 do Fastwrite(X,I,Attrib,Vertline)
  215.       else
  216.          For I := Y2 to Y1 do Fastwrite(X,I,Attrib,Vertline);
  217.   end;   {vertline}
  218.  
  219.   Procedure WriteAT(X,Y,F,B:integer;St:string);
  220.   begin
  221.       Fastwrite(X,Y,attr(F,B),St);
  222.   end;
  223.  
  224.   Procedure WriteCenter(LineNO,F,B:integer;St:string);
  225.   begin
  226.       Fastwrite(40 - length(St) div 2,Lineno,attr(F,B),St);
  227.   end;
  228.  
  229.   Procedure WriteBetween(X1,X2,Y,F,B:byte;St:string);
  230.   var X : integer;
  231.   begin
  232.       If length(St) >= X2 - X1 + 1 then
  233.          WriteAT(X1,Y,F,B,St)
  234.       else
  235.       begin
  236.           x := X1 + (X2 - X1 + 1 - length(St)) div 2 ;
  237.           WriteAT(X,Y,F,B,St);
  238.       end;
  239.   end;
  240.  
  241.   Procedure WriteVert(X,Y,F,B:integer;ST : string);
  242.   var
  243.     I:integer;
  244.     Tempstr:string;
  245.   begin
  246.       If length(St) > 26 - Y then delete(St,27 - Y,80);
  247.       For I := 1 to length(St) do
  248.       begin
  249.           Tempstr := st[I];
  250.           Fastwrite(X,Y-1+I,attr(F,B),St[I]);
  251.       end;
  252.   end;
  253.  
  254.  
  255.   Procedure ReinitFastWrite;
  256.     {-Initializes WaitForRetrace and BaseOfScreen}
  257.   begin                      {InitFastWrite}
  258.     {initialize WaitForRetrace and BaseOfScreen}
  259.     if CurrentVideoMode = 7 then
  260.        BaseOfScreen := $B000  {Mono}
  261.     else
  262.        BaseOfScreen := $B800; {Color}
  263.     WaitForRetrace := (CurrentDisplay = CGA);
  264.  end;                       {InitFastWrite}
  265.  
  266. begin   {the following is always called when the unit is loaded}
  267.     ReinitFastWrite;
  268.     Speed := 200;
  269. end.
  270.